home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / continuation.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  44 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4. ; Continuations
  5.  
  6. (define (continuation-cont     c) (continuation-ref c 0))
  7. (define (continuation-pc       c) (continuation-ref c 1))
  8. (define (continuation-template c) (continuation-ref c 2))
  9. (define (continuation-env      c) (continuation-ref c 3))
  10. (define continuation-overhead 4)
  11. (define (continuation-arg c i)
  12.   (continuation-ref c (+ continuation-overhead i)))
  13. (define (continuation-arg-count c)
  14.   (- (continuation-length c) continuation-overhead))
  15.  
  16.  
  17. ; If (continuation-cont A) = B, then ignore B if
  18. ;   1. (continuation-template B) = (continuation-template A)
  19. ;   2. (continuation-pc B) > (continuation-pc A)
  20. ;   3. (continuation-env B) = (continuation-env A)
  21. ;                             or some parent of (continuation-env A)
  22. ; I don't think this is foolproof, but I have so far been unable to
  23. ; contrive a situation in which it fails.  I think a double recursion of a 
  24. ; procedure of no arguments is required, at the very least.
  25.  
  26. (define (continuation-parent a)
  27.   (let ((b (continuation-cont a)))
  28.     (if (and (continuation? b)
  29.          (eq? (continuation-template b) (continuation-template a))
  30.          (> (continuation-pc b) (continuation-pc a))
  31.          (let loop ((env (continuation-env a)))
  32.            (or (eq? env (continuation-env b))
  33.            (and (vector? env)
  34.             (loop (vector-ref env 0))))))
  35.     (continuation-parent b)
  36.     b)))
  37.  
  38. (define-simple-type :continuation (:value) continuation?)
  39.  
  40. (define-method &disclose ((obj :continuation))
  41.   (list 'continuation
  42.     `(pc ,(continuation-pc obj))
  43.     (template-info (continuation-template obj))))
  44.